home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / views / pop-up-select-icon-view.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  8.5 KB  |  246 lines  |  [TEXT/CCL2]
  1. ;;; pop-up-select-icon-view.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; This is a specialization of pop up view.  Inside of a pop up view,
  12. ;;; a palette of icons are drawn.  The user can select an icon by moving
  13. ;;; the mouse to it.  The identifier of the selected icon is returned.
  14. ;;;
  15. ;;; USE:
  16. ;;;
  17. ;;; pop-up-select-icon-view  - object class, DO NOT INSTALL THIS AS A VIEW.
  18. ;;;   :icons    - list consisting of one of the following:
  19. ;;;               1)  icon resource ID or handle (color-p = nil)
  20. ;;;               2)  cicn resource ID or handle (color-p = t)
  21. ;;;               3)  list: (<ID or handle> <nickname>)
  22. ;;;   :icon-size   - icon encoded point size
  23. ;;;   :max-column  - max number of icons displayed side by side before 
  24. ;;;                  starting a new row
  25. ;;;   :color-p  - color icons (cicn resource) or bw icons (icon resource)
  26. ;;;   :color-list  - same as pop up view
  27. ;;;
  28. ;;; puv-select-icon - called in response to a click event, this displays
  29. ;;;                   the icon palette
  30. ;;;
  31. ;;; pusiv-destroy - dispose icon data
  32. ;;;
  33. ;;; HISTORY:
  34. ;;;
  35. ;;; 7/21/92 Created.  - PM
  36. ;;;
  37.  
  38. (in-package :ccl)
  39.  
  40. (require :pop-up-view)
  41.  
  42. (export '(pop-up-select-icon-view puv-select-icon pusiv-destroy)
  43.         :ccl)
  44.  
  45.  
  46. (defclass pop-up-select-icon-view (pop-up-view)
  47.   ((icons :initarg :icons :accessor icons)
  48.    (icon-nicknames :accessor icon-nicknames)
  49.    (icon-size :initarg :icon-size :accessor i-size)
  50.    (max-column :initarg :max-column :accessor max-col)
  51.    (separation :initarg :separation :accessor gap)
  52.    (color-p :initarg :color-p :accessor color-p))
  53.   (:default-initargs
  54.     :icons ()
  55.     :icon-size #@(16 16)
  56.     :max-column 5
  57.     :separation 7
  58.     :color-p t
  59.     )
  60.   )
  61.  
  62.  
  63. (defmethod initialize-instance ((pusiv pop-up-select-icon-view) &rest initargs)
  64.   (apply #'call-next-method pusiv initargs)
  65.   
  66.   (setf (draw-fn pusiv)
  67.         #'(lambda (view size data)
  68.             (declare (ignore view size data))
  69.             (puv-draw-icons pusiv)))
  70.   
  71.   (let ((nicknames ())
  72.         (icons ()))
  73.     (dolist (icon (icons pusiv))
  74.       (cond ((listp icon)
  75.              (push (first icon) icons)
  76.              (push (second icon) nicknames))
  77.             (t (push icon icons))))
  78.     (setf (icon-nicknames pusiv) nicknames)
  79.     (setf (icons pusiv) icons))
  80.                     
  81.   (let ((i-handles ()))
  82.     (dolist (icon (icons pusiv) (setf (icons pusiv) (nreverse i-handles)))
  83.       (unless (or (typep icon 'fixnum) (pointerp icon))
  84.         (error "~s is not a valid icon (not a resource-id or pointer)."))
  85.       (cond ((typep icon 'fixnum)
  86.              (let ((i-handle (if (color-p pusiv)
  87.                                (#_getCicon icon)
  88.                                (#_geticon icon))))
  89.                (if (%null-ptr-p i-handle)
  90.                  (error "no icon resource with id ~s." icon)
  91.                  (push i-handle i-handles))))
  92.             (t (push icon i-handles))) ))
  93.   
  94.   (let* ((n-icons (length (icons pusiv)))
  95.          (rows (ceiling n-icons (max-col pusiv)))
  96.          (cell-size-h (+ (gap pusiv) (point-h (i-size pusiv))))
  97.          (cell-size-v (+ (gap pusiv) (point-v (i-size pusiv))))
  98.          (width (if (< n-icons (max-col pusiv)) 
  99.                   n-icons 
  100.                   (max-col pusiv))))
  101.     (setf (size pusiv)
  102.           (make-point (+ (* cell-size-h width) (gap pusiv) 2)
  103.                       (+ (* cell-size-v rows) (gap pusiv) 2))) ))
  104.  
  105.  
  106. (defmethod pusiv-destroy ((pusiv pop-up-select-icon-view))
  107.   (if (color-p pusiv)
  108.     (dolist (icon (icons pusiv))
  109.       (#_DisposCIcon icon))) )
  110.  
  111.  
  112. (defmethod puv-select-icon ((pusiv pop-up-select-icon-view) view)
  113.   (let* ((pop-up-view (puv-store-onscreen-view *puv-info*))
  114.          (user-selected-icon nil)
  115.          (old-pen-size (pref (wptr view) windowRecord.pnsize))
  116.          (window-view (view-window view)))
  117.     (copy-background-offscreen window-view (size pusiv))
  118.     (puv-draw pusiv pop-up-view nil)
  119.     (with-port (wptr view) (#_PenSize :long #@(3 3)))
  120.     (setf user-selected-icon (puv-user-choose-icon pusiv pop-up-view))
  121.     (with-port (wptr view) (#_PenSize :long old-pen-size))
  122.     (restore-background window-view)
  123.     user-selected-icon ))
  124.  
  125.  
  126. (defmethod puv-user-choose-icon ((pusiv pop-up-select-icon-view) view)
  127.   (let (choice)
  128.     (with-focused-view view
  129.       (do* ((old-topleft -100)
  130.             (old-bottomright -100)
  131.             (draw-state 'drawn)
  132.             (cell-size-h (+ (gap pusiv) (point-h (i-size pusiv))))
  133.             (cell-size-v (+ (gap pusiv) (point-v (i-size pusiv))))
  134.             (pos (view-mouse-position view) (view-mouse-position view))
  135.             (column (floor (point-h pos) cell-size-h) 
  136.                     (floor (point-h pos) cell-size-h))
  137.             (row (floor (point-v pos) cell-size-v) 
  138.                  (floor (point-v pos) cell-size-v))
  139.             (topleft (make-point (- (+ (gap pusiv) (* column cell-size-h)) 3) 
  140.                                  (- (+ (gap pusiv) (* row cell-size-v)) 3))
  141.                      (make-point (- (+ (gap pusiv) (* column cell-size-h)) 3) 
  142.                                  (- (+ (gap pusiv) (* row cell-size-v)) 3)))
  143.             (bottomright (add-points topleft (make-point (1- cell-size-h) (1- cell-size-v)))
  144.                          (add-points topleft (make-point (1- cell-size-h) (1- cell-size-v)))))
  145.            ((not (mouse-down-p)))
  146.         
  147.         (setf choice (+ column (* row (max-col pusiv))))
  148.         
  149.         (when (and (or (/= topleft old-topleft) (/= bottomright old-bottomright))
  150.                    (eq draw-state 'drawn))
  151.           (with-port (wptr view) (#_PenMode #$srcXor))
  152.           (with-fore-color *red-color*
  153.             (rlet ((r :rect :topleft old-topleft :bottomright old-bottomright))
  154.               (#_FrameRect r)))
  155.           (with-port (wptr view) (#_PenMode #$srcCopy))
  156.           (setf draw-state 'erased))
  157.         (when (and (<= 0 column (1- (max-col pusiv))) 
  158.                    (<= 0 choice (1- (length (icons pusiv))))
  159.                    (eq draw-state 'erased))
  160.           (with-port (wptr view) (#_PenMode #$srcXor))
  161.           (with-fore-color *black-color*
  162.             (rlet ((r :rect :topleft topleft :bottomright bottomright))
  163.               (#_FrameRect r)))
  164.           (with-port (wptr view) (#_PenMode #$srcCopy))
  165.           (setf draw-state 'drawn)
  166.           (setf old-topleft topleft)
  167.           (setf old-bottomright bottomright) )) )
  168.     
  169.     (if (<= 0 choice (1- (length (icons pusiv))))
  170.       (if (>= (1- (length (icon-nicknames pusiv))) choice)
  171.         (nth choice (icon-nicknames pusiv))
  172.         choice)
  173.       nil) ))
  174.  
  175.  
  176. (defmethod puv-draw-icons ((pusiv pop-up-select-icon-view))
  177.   (let ((cell-size-h (+ (gap pusiv) (point-h (i-size pusiv))))
  178.         (cell-size-v (+ (gap pusiv) (point-v (i-size pusiv))))
  179.         (offset (make-point (ceiling (gap pusiv) 2) (ceiling (gap pusiv) 2))))
  180.     (dotimes (n (length (icons pusiv)))
  181.       (let* ((icon (nth n (icons pusiv)))
  182.              (row (floor n (max-col pusiv)))
  183.              (column (- n (* row (max-col pusiv))))
  184.              (topleft (make-point (+ (gap pusiv) (* column cell-size-h)) 
  185.                                   (+ (gap pusiv) (* row cell-size-v))))
  186.              (bottomright (add-points topleft (i-size pusiv))))
  187.  
  188.         (rlet ((r :rect :topleft topleft :bottomright bottomright)
  189.                (r1 :rect 
  190.                    :topleft (subtract-points topleft offset)
  191.                    :bottomright (add-points bottomright offset)))
  192.           (if (color-p pusiv)
  193.             (#_plotCicon r icon)
  194.             (#_ploticon r icon))
  195.           (#_framerect r1))) )))
  196.  
  197.  
  198. (provide :pop-up-select-icon-view)
  199.  
  200.              
  201. #|
  202. ; Example
  203.  
  204. (require :quickdraw)
  205.  
  206. (puv-init)
  207. ;(puv-destroy)
  208.  
  209. (defclass foo-window (window)
  210.   ()
  211.   (:default-initargs
  212.     :view-size #@(300 300)
  213.     :color-p t
  214.   )
  215. )
  216.  
  217. (defvar *bw-pusiv*)
  218.  
  219. (setf *bw-pusiv* 
  220.   (make-instance 'pop-up-select-icon-view
  221.     :color-p nil
  222.     :icon-size #@(32 32)
  223.     :icons '(0 1 2 0)
  224.     :max-column 2
  225.     :color-list (list :background *yellow-color*
  226.                       :frame *light-blue-color*
  227.                       :shadow *blue-color*)))
  228.  
  229. (defmethod view-draw-contents ((view foo-window))
  230.   (dotimes (i 60)
  231.     (with-fore-color (random most-positive-fixnum)
  232.       (move-to view 10 (+ 20 (* i 2)))
  233.       (line-to view 100 (+ 20 (* i 4)))))
  234.   (move-to view 10 20)
  235.   (format view "Click here."))
  236.  
  237. (defmethod view-click-event-handler ((view foo-window) where)
  238.   (declare (ignore where))
  239.   (let ((selection (puv-select-icon *bw-pusiv* view)))
  240.     (if selection
  241.       (dotimes (i (1+ selection))
  242.         (ed-beep)))))
  243.  
  244. (setf w (make-instance 'foo-window))
  245. |#
  246.